home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / bipl.zip / PROGS.ZIP / HCAL4UNX.ICN < prev    next >
Text File  |  1993-01-27  |  24KB  |  950 lines
  1. ##########################################################################
  2. #
  3. #    File:     hcal4unx.icn
  4. #
  5. #    Subject:  Program for combination Jewish/Civil calendar
  6. #
  7. #    Author:   Alan D. Corre (ported to UNIX by Richard L. Goerwitz)
  8. #
  9. #    Date:     June 4, 1991
  10. #
  11. #########################################################################
  12. #
  13. #    Version:  1.16
  14. #
  15. ###########################################################################
  16. #
  17. #  This work is respectfully devoted to the authors of two books
  18. #  consulted with much profit: "A Guide to the Solar-Lunar Calendar"
  19. #  by B. Elihu Rothblatt published by our sister Hebrew Dept. in
  20. #  Madison, Wis., and "Kiddush HaHodesh" by Rabbenu Moses ben Maimon,
  21. #  on whom be peace.
  22. #
  23. #  The Jewish year harmonizes the solar and lunar cycle, using the
  24. #  19-year cycle of Meton (c. 432 BCE). It corrects so that certain
  25. #  dates shall not fall on certain days for religious convenience. The
  26. #  Jewish year has six possible lengths, 353, 354, 355, 383, 384, and
  27. #  385 days, according to day and time of new year lunation and
  28. #  position in Metonic cycle.  Time figures from 6pm previous night.
  29. #  The lunation of year 1 is calculated to be on a Monday (our Sunday
  30. #  night) at ll:11:20pm. Our data table begins with a hypothetical
  31. #  year 0, corresponding to 3762 B.C.E.  Calculations in this program
  32. #  are figured in the ancient Babylonian unit of halaqim "parts" of
  33. #  the hour = 1/1080 hour.
  34. #
  35. #  Startup syntax is simply hebcalen [date], where date is a year
  36. #  specification of the form 5750 for a Jewish year, +1990 or 1990AD
  37. #  or 1990CE or -1990 or 1990BC or 1990BCE for a civil year.
  38. #
  39. ##########################################################################
  40. #
  41. #  Links: iolib
  42. #
  43. ##########################################################################
  44. #
  45. #  Requires: UNIX, hebcalen.dat, hebcalen.hlp
  46. #
  47. ##########################################################################
  48. #
  49. #  See also: hebcalen.icn
  50. #
  51. ##########################################################################
  52.  
  53. link iolib
  54.  
  55. record date(yr,mth,day)
  56. record molad(day,halaqim)
  57.  
  58. global cyr,jyr,days_in_jyr,current_molad,current_day,infolist
  59.  
  60.  
  61. #------- the following sections of code have been modified  - RLG -------#
  62.  
  63. procedure main(a)
  64.     local n, p
  65.  
  66.     iputs(getval("ti"))
  67.     display_startup_screen()
  68.  
  69.     if *a = 0 then {
  70.     #put()'ing an asterisk means that user might need help
  71.     n := 1; put(a,"*")
  72.     }
  73.     else n := *a
  74.     every p := 1 to n do {
  75.     initialize(a[p]) | break
  76.     process() | break
  77.     }
  78.     iputs(getval("te"))
  79.  
  80. end
  81.  
  82.  
  83.  
  84. procedure display_startup_screen()
  85.  
  86.     local T
  87.  
  88.     clear()
  89.     banner("PERPETUAL JEWISH/CIVIL CALENDAR","by","ALAN D. CORRE")
  90.     # Use a combination of tricks to be sure it will be up there a sec.
  91.     every 1 to 10000
  92.     T := &time; until &time > (T+450)
  93.  
  94.     return
  95.  
  96. end
  97.  
  98.  
  99.  
  100. procedure banner(l[])
  101.  
  102.     # Creates a banner to begin hebcalen.  Leaves it on the screen for
  103.     # about a second.
  104.  
  105.     local m, n, CM, COLS, LINES
  106.  
  107.     CM    := getval("cm")
  108.     COLS  := getval("co")
  109.     LINES := getval("li")
  110.     (COLS > 55, LINES > 9) |
  111.     stop("\nSorry, your terminal just isn't big enough.")
  112.  
  113.     if LINES > 20 then {
  114.     # Terminal is big enough for banner.
  115.     iputs(igoto(CM,1,3))
  116.     writes("+",repl("-",COLS-3),"+")
  117.     iputs(igoto(CM,1,4))
  118.     writes("|")
  119.     iputs(igoto(CM,COLS-1,4))
  120.     writes("|")
  121.  
  122.     m := 0
  123.     every n := 5 to (*l * 3) + 4 by 3 do {
  124.         iputs(igoto(CM,1,n))
  125.         writes("|",center(l[m+:=1],COLS-3),"|")
  126.         every iputs(igoto(CM,1,n+(1|2))) & writes("|")
  127.         every iputs(igoto(CM,COLS-1,n+(1|2))) & writes("|")
  128.     }
  129.     
  130.     iputs(igoto(CM,1,n+3))
  131.     writes("+",repl("-",COLS-3),"+")
  132.     iputs(igoto(CM,1,n+4))
  133.     write(" Copyright (c) Alan D. Corre, 1990")
  134.     }
  135.     else {
  136.     # Terminal is extremely short
  137.     iputs(igoto(CM,1,(LINES/2)-1))
  138.     write(center(l[1],COLS))
  139.     write(center("Copyright (c) Alan D. Corre, 1990",COLS))
  140.     }    
  141.  
  142.     return
  143.  
  144. end
  145.  
  146.  
  147.  
  148. procedure get_paths()
  149.  
  150.     local paths, p
  151.  
  152.     suspend "./" | "/usr/local/lib/hebcalen/"
  153.     paths := getenv("PATH")
  154.     \paths ? {
  155.     tab(match(":"))
  156.     while p := 1(tab(find(":")), move(1))
  157.     do suspend "" ~== trim(p,'/ ') || "/"
  158.     return "" ~== trim(tab(0) \ 1,'/ ') || "/"
  159.     }
  160.  
  161. end
  162.  
  163.  
  164.  
  165. procedure instructions(filename)
  166.  
  167.     # Gives user access to a help file which is printed out in chunks
  168.     # by "more."
  169.  
  170.     local helpfile, pager, ans, more_file
  171.  
  172.     iputs(igoto(getval("cm"),1,2))
  173.     writes("Do you need instructions? [ny]  ")
  174.     ans := map(read())
  175.     "q" == ans & fail
  176.  
  177.     if "y" == ans then {
  178.     clear()
  179.     write()
  180.     if close(open(helpfile := (get_paths()||filename)))
  181.     then {
  182.         # Kludge, kludge, kludge.
  183.         close(open(
  184.         more_file := (
  185.             ("" ~== getenv("PAGER")) |
  186.             (("/bin/"|"/usr/ucb/"|"/usr/bin/")||"more"))))
  187.         system(more_file || " " || helpfile)
  188.     }
  189.     else write("Can't find your hebcalen.hlp file!")
  190.     iputs(igoto(getval("cm"),1,getval("li")))
  191.     boldface()
  192.     writes("Press return to continue.")
  193.     normal()
  194.     "q" == map(read()) & fail
  195.     }
  196.  
  197.     return \helpfile | "no help"
  198.  
  199. end
  200.  
  201.  
  202.  
  203. procedure clear()
  204.     local i
  205.  
  206.     # Clears the screen.  Tries several methods.
  207.  
  208.     if not iputs(getval("cl"))
  209.     then iputs(igoto(getval("cm"),1,1))
  210.     if not iputs(getval("cd"))
  211.     then {
  212.     every i := 1 to getval("li") do {
  213.         iputs(igoto(getval("cm"),1,i))
  214.         iputs(getval("ce"))
  215.     }
  216.     iputs(igoto(getval("cm"),1,1))
  217.     }
  218.  
  219. end
  220.  
  221.  
  222.  
  223. procedure initialize_list()
  224.  
  225.     # Put info of hebcalen.dat into a global list
  226.  
  227.     local infile,n
  228.  
  229.     infolist := list(301)
  230.     if not (infile := open(get_paths()||"hebcalen.dat")) then
  231.     stop("\nError:  cannot open hebcalen.dat")
  232.  
  233.     # The table is arranged at twenty year intervals with 301 entries.
  234.     every n := 1 to 301 do
  235.     infolist[n] := read(infile)
  236.     close(infile)
  237.  
  238. end
  239.  
  240.  
  241.  
  242. procedure initialize_variables()
  243.  
  244.     # Get the closest previous year in the table.
  245.  
  246.     local line, quotient
  247.  
  248.     quotient := jyr.yr / 20 + 1
  249.     # Only 301 entries. Figure from last if necessary.
  250.     if quotient > 301 then quotient := 301
  251.     # Pull the appropriate info, put into global variables.
  252.     line := infolist[quotient]
  253.  
  254.     line ? {
  255.     current_molad.day := tab(upto('%'))
  256.     move(1)
  257.     current_molad.halaqim := tab(upto('%'))
  258.     move(1)
  259.     cyr.mth := tab(upto('%'))
  260.     move(1)
  261.     cyr.day := tab(upto('%'))
  262.     move(1)
  263.     cyr.yr := tab(upto('%'))
  264.     days_in_jyr := line[-3:0]
  265.     }
  266.  
  267.     # Begin at rosh hashana.
  268.     jyr.day := 1
  269.     jyr.mth := 7
  270.     return
  271.  
  272. end
  273.  
  274.  
  275.  
  276. procedure initialize(yr)
  277.  
  278.     local year
  279.     static current_year
  280.  
  281.     # initialize global variables
  282.     initial {
  283.     cyr := date(0,0,0)
  284.     jyr := date(0,0,0)
  285.     current_molad := molad(0,0)
  286.     initialize_list()
  287.     current_year := get_current_year()
  288.     }
  289.  
  290.     clear()
  291.     #user may need help
  292.     if yr == "*" then {
  293.     instructions("hebcalen.hlp") | fail
  294.     clear()
  295.     iputs(igoto(getval("cm"),1,2))
  296.     write("Enter a year.  By default, all dates are interpreted")
  297.     write("according to the Jewish calendar.  Civil years should")
  298.     write("be preceded by a + or - sign to indicate occurrence")
  299.     write("relative to the beginning of the common era (the cur-")
  300.     writes("rent civil year, ",current_year,", is the default):  ")
  301.     boldface()
  302.     year := read()
  303.     normal()
  304.     "q" == map(year) & fail
  305.     }
  306.     else year := yr
  307.  
  308.     "" == year & year := current_year
  309.     until jyr.yr := cleanup(year) do {
  310.     writes("\nI don't consider ")
  311.     boldface()
  312.     writes(year)
  313.     normal()
  314.     writes(" a valid date.  Try again:  ")
  315.     boldface()
  316.     year := read()
  317.     normal()
  318.     "q" == map(year) & fail
  319.     "" == year & year := current_year
  320.     }
  321.  
  322.     clear()
  323.     initialize_variables()
  324.     return
  325.  
  326. end
  327.  
  328.  
  329.  
  330. procedure get_current_year()
  331.     local c_date
  332.  
  333.     &date ? c_date := tab(find("/"))
  334.     return "+" || c_date
  335. end
  336.  
  337.  
  338.  
  339. procedure cleanup(str)
  340.  
  341.     # Tidy up the string. Bugs still possible.
  342.  
  343.     if "" == trim(str) then return ""
  344.  
  345.     map(Strip(str,~(&digits++'ABCDE+-'))) ? {
  346.  
  347.     if find("-"|"bc"|"bcd")
  348.     then return (0 < (3761 - (0 ~= checkstr(str))))
  349.     else if find("+"|"ad"|"ce")
  350.     then return ((0 ~= checkstr(str)) + 3760)
  351.     else if 0 < integer(str)
  352.     then return str
  353.     else fail
  354.     
  355.     }
  356.  
  357. end
  358.  
  359.  
  360.  
  361. procedure Strip(s,c)
  362.     local s2
  363.  
  364.     s2 := ""
  365.     s ? {
  366.     while s2 ||:= tab(upto(c))
  367.     do tab(many(c))
  368.     s2 ||:= tab(0)
  369.     }
  370.     return s2
  371.  
  372. end
  373.  
  374.  
  375.  
  376. procedure checkstr(s)
  377.  
  378.     # Does preliminary work on string before cleanup() cleans it up.
  379.  
  380.     local letter,n,newstr
  381.  
  382.     newstr := ""
  383.     every newstr ||:= string(integer(!s))
  384.     if 0 = *newstr | "" == newstr
  385.     then fail
  386.     else return newstr
  387.  
  388. end
  389.  
  390.  
  391.  
  392. procedure process()
  393.     local ans, yj, n
  394.  
  395.     # Extracts information about the specified year.
  396.  
  397.     local msg, limit, dj, dc, month_count, done
  398.     static how_many_per_screen, how_many_screens
  399.     initial {
  400.     how_many_per_screen := how_many_can_fit()
  401.     (how_many_screens := seq()) * how_many_per_screen >= 12
  402.     }
  403.  
  404.     # 6019 is last year handled by the table in the usual way.
  405.     if jyr.yr > 6019
  406.     then msg := "Calculating.  Years over 6019 take a long time."
  407.     else msg := "Calculating."
  408.     if jyr.yr <= 6019 then {
  409.     limit := jyr.yr % 20 
  410.     jyr.yr := ((jyr.yr / 20) * 20)
  411.     }
  412.     else {
  413.     limit := jyr.yr - 6000
  414.     jyr.yr := 6000
  415.     }
  416.     
  417.     ans := "y"
  418.     establish_jyr()
  419.     iputs(igoto(getval("cm"),1,2))
  420.     writes(msg)
  421.     every 1 to limit do {
  422.     # Increment the years, establish the type of Jewish year
  423.     cyr_augment()
  424.     jyr_augment()
  425.     establish_jyr()
  426.     }
  427.  
  428.     clear() 
  429.     while ("y"|"") == map(ans) do {
  430.  
  431.     yj := jyr.yr
  432.     dj := days_in_jyr
  433.  
  434.     month_count := 0
  435.     # On the variable how_many_screens, see initial { } above
  436.     every n := 1 to how_many_screens do {
  437.         clear()
  438.         every 1 to how_many_per_screen do {
  439.         write_a_month()
  440.         (month_count +:= 1) = 12 & break
  441.         }
  442.         if month_count < 12 | (12 % (13 > how_many_per_screen)) = 0
  443.         then {
  444.  
  445.         iputs(igoto(getval("cm"),1,getval("li")-2))
  446.         boldface()
  447.         writes(status_line(yj,dj))
  448.         normal()
  449.  
  450.         if month_count < 12 | jyr.mth = 6 then {
  451.             iputs(igoto(getval("cm"),1,getval("li")-1))
  452.             writes("Press return to continue.  ")
  453.             "q" == map(read()) & fail
  454.         }
  455.         }
  456.     }
  457.  
  458.     if jyr.mth = 6 then {
  459.         if (12 % (13 > how_many_per_screen)) = 0
  460.         then clear()
  461.         write_a_month()
  462.     }
  463.     iputs(igoto(getval("cm"),1,getval("li")-2))
  464.     boldface()
  465.     writes(status_line(yj,dj))
  466.     normal()
  467.  
  468.     iputs(igoto(getval("cm"),1,getval("li")-1))
  469.     writes("Display the next year? [yn]  ")
  470.     ans := read()
  471.  
  472.     }
  473.     return
  474.  
  475. end
  476.  
  477.  
  478.  
  479. procedure how_many_can_fit()
  480.  
  481.     local LINES, how_many
  482.  
  483.     LINES := getval("li") + 1
  484.     (((8 * (how_many := 1 to 14)) / LINES) = 1)
  485.  
  486.     return how_many - 1
  487.  
  488. end
  489.  
  490.  
  491.  
  492. procedure cyr_augment()
  493.  
  494.     # Make civil year a year later, we only need consider Aug,Sep,Nov.
  495.  
  496.     local days,newmonth,newday
  497.  
  498.     if cyr.mth = 8 then
  499.     days := 0 else
  500.     if cyr.mth = 9 then
  501.     days := 31 else
  502.     if cyr.mth = 10 then
  503.     days := 61 else
  504.     stop("Error in cyr_augment")
  505.  
  506.     writes(".")
  507.  
  508.     days := (days + cyr.day-365+days_in_jyr)
  509.     if isleap(cyr.yr + 1) then days -:= 1
  510.  
  511.     # Cos it takes longer to get there.
  512.     if days <= 31 then {newmonth := 8; newday := days} else
  513.     if days <= 61 then {newmonth := 9; newday := days-31} else
  514.     {newmonth := 10; newday := days-61} 
  515.  
  516.     cyr.mth := newmonth
  517.     cyr.day := newday
  518.     cyr.yr +:= 1
  519.     if cyr.yr = 0 then cyr.yr := 1
  520.  
  521.     return
  522.  
  523. end
  524.  
  525.  
  526.  
  527. procedure header()
  528.     local COLS
  529.  
  530.     # Creates the header for Jewish and English side.  Bug:  This
  531.     # routine, as it stands, has to rewrite the entire screen, in-
  532.     # cluding blank spaces.  Many of these could be elminated by
  533.     # judicious line clears and/or cursor movement commands.  Do-
  534.     # ing so would certainly speed up screen refresh for lower
  535.     # baud rates.  I've utilized the ch command where available,
  536.     # but in most cases, plain old spaces must be output.
  537.  
  538.     static make_whitespace, whitespace
  539.     initial {
  540.     COLS := getval("co")
  541.     if getval("ch") then {
  542.         # Untested, but it would offer a BIG speed advantage!
  543.         make_whitespace := create |iputs(igoto(getval("ch"),(COLS-53)+25))
  544.     }
  545.     else {
  546.         # Have to do things this way, since we don't know what line
  547.         # we are on (cm commands usually default to row/col 1).
  548.         whitespace := repl(" ",COLS-53)
  549.         make_whitespace := create |writes(whitespace)
  550.     }
  551.     }
  552.  
  553.     writes(repl(" ",7),"S",repl(" ",2),"M",repl(" ",2),"T",repl(" ",2),"W",
  554.        repl(" ",2),"T",repl(" ",2),"F",repl(" ",2))
  555.     boldface()
  556.     writes("S")
  557.     normal()
  558.     @make_whitespace
  559.     writes("S",repl(" ",2),"M",repl(" ",2),"T",repl(" ",2),"W",
  560.         repl(" ",2),"T",repl(" ",2),"F",repl(" ",2))
  561.     boldface()
  562.     writes("S")
  563.     normal()
  564.     iputs(getval("ce"))
  565.     write()
  566.  
  567. end
  568.  
  569.  
  570.  
  571. procedure write_a_month()
  572.  
  573.     # Writes a month on the screen
  574.  
  575.     header()
  576.     every 1 to 5 do {
  577.     writes(make_a_line())
  578.     iputs(getval("ce"))
  579.     write()
  580.     }
  581.     if jyr.day ~= 1 then {
  582.     writes(make_a_line())
  583.     iputs(getval("ce"))
  584.     write()
  585.     }
  586.     iputs(getval("ce"))
  587.     write()
  588.  
  589.     return
  590.  
  591. end
  592.  
  593.  
  594.  
  595. procedure status_line(a,b)
  596.  
  597.     # Create the status line at the bottom of screen.
  598.  
  599.     local sline,c,d
  600.  
  601.     c := cyr.yr
  602.     if (cyr.day = 1) & (cyr.mth = 1) then c -:= 1
  603.     d := { if isleap(c) then 366 else 365 }
  604.     if getval("co") > 79 then {
  605.     sline := ("Year of Creation: " || a || "  Days in year: " || b ||
  606.           "  Civil year: " || c || "  Days in year: " || d)
  607.     }
  608.     else {
  609.     sline := ("Jewish year " || a || " (" || b || " days)," ||
  610.           " Civil year " || c || " (" || d || " days)")
  611.     }
  612.  
  613.     return center(sline,getval("co"))
  614.  
  615. end
  616.  
  617.  
  618.  
  619. procedure boldface()
  620.     
  621.     static bold_str, cookie_str
  622.     initial {
  623.     if bold_str := getval("so")
  624.     then cookie_str := repl(getval("bc") | "\b", getval("sg"))
  625.     else {
  626.         if bold_str := getval("ul")
  627.         then cookie_str := repl(getval("bc") | "\b", getval("ug"))
  628.     }
  629.     }        
  630.     
  631.     iputs(\bold_str)
  632.     iputs(\cookie_str)
  633.     return
  634.  
  635. end
  636.  
  637.  
  638.  
  639. procedure normal()
  640.  
  641.     static UN_bold_str, cookie_str
  642.     initial {
  643.     if UN_bold_str := getval("se")
  644.     then cookie_str := repl(getval("bc") | "\b", getval("sg"))
  645.     else {
  646.         if UN_bold_str := getval("ue")
  647.         then cookie_str := repl(getval("bc") | "\b", getval("ug"))
  648.     }
  649.     }        
  650.     
  651.     iputs(\UN_bold_str)
  652.     iputs(\cookie_str)
  653.     return
  654.  
  655. end
  656.  
  657.  
  658. #--------------------- end modified sections of code ----------------------#
  659.  
  660. # Okay, okay a couple of things have been modified below, but nothing major.
  661.  
  662. procedure make_a_line()
  663. #make a single line of the months
  664. local line,blanks1,blanks2,start_point,end_point,flag,fm
  665. static number_of_spaces
  666. initial number_of_spaces := getval("co")-55
  667.  
  668. #consider the first line of the month
  669.   if jyr.day = 1 then {
  670.     line := mth_table(jyr.mth,1)
  671. #setting flag means insert civil month at end of line    
  672.     flag := 1 } else
  673.     line := repl(" ",3)
  674. #consider the case where first day of civil month is on Sunday    
  675.   if (cyr.day = 1) & (current_day = 1) then flag := 1
  676. #space between month name and beginning of calendar
  677.   line ||:= repl(" ",2)
  678. #measure indentation for first line
  679.   line ||:= blanks1 := repl(" ",3*(current_day-1))
  680. #establish start point for Hebrew loop
  681.   start_point := current_day
  682. #establish end point for Hebrew loop and run civil loop
  683.   every end_point := start_point to 7 do {
  684.     line ||:= right(jyr.day,3)
  685.     if not j_augment() then {jyr_augment(); establish_jyr(); current_day -:= 1; if current_day = 0 then current_day := 7}
  686.     d_augment()
  687.     if jyr.day = 1 then break }
  688. #measure indentation for last line
  689.   blanks2 := repl(" ",3*(7-end_point))
  690.   line ||:= blanks2; line ||:= repl(" ",number_of_spaces); line ||:= blanks1
  691.   every start_point to end_point do {
  692.     line ||:= right(cyr.day,3)
  693.     if (cyr.day = 1) then flag := 1 
  694.     augment()}
  695.   line ||:= blanks2 ||:= repl(" ",3)
  696.   fm := cyr.mth
  697.   if cyr.day = 1 then
  698.     if cyr.mth = 1 then fm := 12 else fm := cyr.mth - 1
  699.   if \flag then line ||:= mth_table(fm,2) else
  700.     line ||:= repl(" ",3)
  701. return line
  702. end
  703.  
  704. procedure mth_table(n,p)
  705. #generates the short names of Jewish and Civil months. Get to civil side
  706. #by adding 13 (=max no of Jewish months)
  707. static corresp
  708. initial corresp := ["NIS","IYA","SIV","TAM","AV ","ELU","TIS","HES","KIS",
  709. "TEV","SHE","ADA","AD2","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP",
  710. "OCT","NOV","DEC"]
  711.   if (p ~= 1) & (p ~= 2) then stop("ERROR IN MTH-TABLE") else
  712.     if p = 2 then n +:= 13
  713. return corresp[n]
  714. end
  715.  
  716. procedure d_augment()
  717. #increment the day of the week
  718.   current_day +:= 1
  719.   if current_day = 8 then current_day := 1
  720. return
  721. end
  722.  
  723. procedure augment()
  724. #increments civil day, modifies month and year if necessary, stores in
  725. #global variable cyr
  726.   if cyr.day < 28 then
  727.     cyr.day +:= 1 else
  728.   if cyr.day = 28 then {
  729.     if (cyr.mth ~= 2) | ((cyr.mth = 2) & isleap(cyr.yr)) then
  730.       cyr.day := 29 else {
  731.         cyr.mth := 3
  732.     cyr.day  := 1}} else
  733.   if cyr.day = 29 then {
  734.     if cyr.mth ~= 2 then
  735.       cyr.day := 30 else {
  736.       cyr.mth := 3
  737.       cyr.day := 1}} else
  738.   if cyr.day = 30 then {
  739.     if is_31(cyr.mth) then
  740.       cyr.day := 31 else {
  741.       cyr.mth +:= 1
  742.       cyr.day := 1}} else {
  743.       cyr.day := 1
  744.       if cyr.mth ~= 12 then
  745.         cyr.mth +:= 1 else {
  746.         cyr.mth := 1
  747.         cyr.yr +:= 1
  748.         if cyr.yr = 0
  749.       then cyr.yr := 1}}
  750. return
  751. end
  752.  
  753. procedure is_31(n)
  754. #civil months with 31 days
  755. return n = 1 | n = 3 | n = 5 | n = 7 | n = 8 | n = 10 | n = 12
  756. end
  757.  
  758. procedure isleap(n)
  759. #checks for civil leap year
  760.   if n > 0 then
  761. return (n % 400 = 0) | ((n % 4 = 0) & (n % 100 ~= 0)) else
  762. return (n % 400 = -1) | ((n % 4 = -1) & (n % 100 ~= -1))
  763. end
  764.  
  765. procedure j_augment()
  766. #increments jewish day. months are numbered from nisan, adar sheni is 13.
  767. #procedure fails at elul to allow determination of type of new year
  768.   if jyr.day < 29 then
  769.     jyr.day +:= 1 else
  770.   if (jyr.day = 30) | always_29(jyr.mth) | ((jyr.mth = 8) & 
  771.     (days_in_jyr % 5 ~= 0)) | ((jyr.mth = 9) & ((days_in_jyr = 353) |
  772.     (days_in_jyr = 383))) then
  773.     jyr.mth +:= jyr.day := 1 else
  774.   if jyr.mth = 6 then fail else
  775.   if ((jyr.mth = 12) & (days_in_jyr < 383)) | (jyr.mth = 13) then
  776.     jyr.mth := jyr.day := 1 else
  777.   jyr.day := 30
  778. return
  779. end
  780.  
  781. procedure always_29(n)
  782. #uncomplicated jewish months with 29 days
  783. return n = 2 | n = 4 | n = 10
  784. end
  785.  
  786. procedure jyr_augment()
  787. #determines the current time of lunation, using the ancient babylonian unit
  788. #of 1/1080 of an hour. lunation of tishri determines type of year. allows
  789. #for leap year. halaqim = parts of the hour
  790. local days, halaqim
  791.   days := current_molad.day + 4
  792.   if days_in_jyr <= 355 then {
  793.     halaqim :=  current_molad.halaqim + 9516
  794.     days := ((days +:= halaqim / 25920) % 7)
  795.     if days = 0 then days := 7
  796.     halaqim := halaqim % 25920} else {
  797.     days +:= 1
  798.     halaqim := current_molad.halaqim + 23269
  799.     days := ((days +:= halaqim / 25920) % 7)
  800.     if days = 0 then days := 7
  801.     halaqim := halaqim % 25920}
  802.   current_molad.day := days
  803.   current_molad.halaqim := halaqim
  804. #reset the global variable which holds the current jewish date
  805.   jyr.yr +:= 1 #increment year
  806.   jyr.day := 1
  807.   jyr.mth := 7
  808.   establish_jyr()
  809. return
  810. end
  811.  
  812. procedure establish_jyr()
  813. #establish the jewish year from get_rh
  814. local res
  815.   res := get_rh(current_molad.day,current_molad.halaqim,no_lunar_yr(jyr.yr))
  816.   days_in_jyr := res[2]
  817.   current_day := res[1]
  818. return
  819. end    
  820.  
  821. procedure isin1(i)
  822. #the isin procedures are sets of years in the Metonic cycle
  823. return i = (1 | 4 | 7 | 9 | 12 | 15 | 18)
  824. end
  825.  
  826. procedure isin2(i)
  827. return i = (2 | 5 | 10 | 13 | 16)
  828. end
  829.  
  830. procedure isin3(i)
  831. return i = (3 | 6 | 8 | 11 | 14 | 17 | 0)
  832. end
  833.  
  834. procedure isin4(i)
  835. return i = (1 | 2 | 4 | 5 | 7 | 9 | 10 | 12 | 13 | 15 | 16 | 18)
  836. end
  837.  
  838. procedure isin5(i)
  839. return i = (1 | 4 | 9 | 12 | 15)
  840. end
  841.  
  842. procedure isin6(i)
  843. return i = (2 | 5 | 7 | 10 | 13 | 16 | 18)
  844. end
  845.  
  846. procedure no_lunar_yr(i)
  847. #what year in the metonic cycle is it?
  848. return i % 19
  849. end
  850.  
  851. procedure get_rh(d,h,yr)
  852. #this is the heart of the program. check the day of lunation of tishri
  853. #and determine where breakpoint is that sets the new moon day in parts
  854. #of the hour. return result in a list where 1 is day of rosh hashana and
  855. #2 is length of jewish year
  856. local c,result
  857.   c := no_lunar_yr(yr)
  858.   result := list(2)
  859.   if d = 1 then {
  860.           result[1] := 2
  861.                 if (h < 9924) & isin4(c) then result[2] := 353 else
  862.         if (h < 22091) & isin3(c) then result[2] := 383 else
  863.         if (h > 9923) & (isin1(c) | isin2(c)) then result[2] := 355 else
  864.         if (h > 22090) & isin3(c) then result[2] := 385
  865.         } else
  866.   if d = 2 then {
  867.           if ((h < 16789) & isin1(c)) |
  868.            ((h < 19440) & isin2(c)) then {
  869.                                  result[1] := 2
  870.                              result[2] := 355
  871.                              } else
  872.         if (h < 19440) & isin3(c) then  {
  873.                                  result[1] := 2
  874.                              result[2] := 385
  875.                              } else
  876.           if ((h > 16788) & isin1(c)) |
  877.            ((h > 19439) & isin2(c)) then {
  878.                                  result[1] := 3
  879.                              result[2] := 354
  880.                              } else
  881.                 if (h > 19439) & isin3(c) then  {
  882.                                  result[1] := 3
  883.                              result[2] := 384
  884.                              }
  885.         } else
  886.   if d = 3 then {
  887.           if (h < 9924) & (isin1(c) | isin2(c)) then {
  888.                                result[1] := 3
  889.                                result[2] := 354
  890.                                } else
  891.         if (h < 19440) & isin3(c) then {
  892.                            result[1] := 3
  893.                            result[2] := 384
  894.                            } else
  895.         if (h > 9923) & isin4(c) then {
  896.                           result[1] := 5
  897.                           result[2] := 354
  898.                           } else
  899.         if (h > 19439) & isin3(c) then {
  900.                            result[1] := 5
  901.                            result[2] := 383}
  902.         } else
  903.   if d = 4 then {
  904.           result[1] := 5
  905.         if isin4(c) then result[2] := 354 else
  906.         if h < 12575 then result[2] := 383 else
  907.         result[2] := 385
  908.         } else
  909.   if d = 5 then {
  910.                 if (h < 9924) & isin4(c) then {
  911.                           result[1] := 5
  912.                           result[2] := 354} else
  913.         if (h < 19440) & isin3(c) then {
  914.                            result[1] := 5
  915.                            result[2] := 385
  916.                            } else
  917.         if (9923 < h < 19440) & isin4(c) then {
  918.                               result[1] := 5
  919.                               result[2] := 355
  920.                               } else
  921.         if h > 19439 then {
  922.                     result[1] := 7
  923.                           if isin3(c) then result[2] := 383 else
  924.                             result[2] := 353
  925.                   }
  926.         } else
  927.   if d = 6 then {
  928.             result[1] := 7
  929.             if ((h < 408) & isin5(c)) | ((h < 9924) & isin6(c)) then
  930.                               result[2] := 353 else
  931.             if ((h < 22091) & isin3(c)) then result[2] := 383 else
  932.             if ((h > 407) & isin5(c)) | ((h > 9923) & isin6(c)) then
  933.                               result[2] := 355 else
  934.             if (h > 22090) & isin3(c) then result[2] := 385
  935.             } else
  936.   if d = 7 then    if (h < 19440) & (isin5(c) | isin6(c)) then {
  937.                               result[1] := 7
  938.                               result[2] := 355
  939.                               } else
  940.         if (h < 19440) & isin3(c) then {
  941.                            result[1] := 7
  942.                            result[2] := 385
  943.                            } else {
  944.                                   result[1] := 2
  945.                               if isin4(c) then
  946.                                 result[2] := 353 else
  947.                             result[2] := 383}
  948. return result
  949. end
  950.